Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/src-16f.lha/compiler/generic/genesis.lisp

Text File | 1992-05-27 | 59.1 KB | 1,790 lines

;;; -*- Package: Lisp -*-
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or [e-mail].
;;;
(ext:file-comment
  "$Header: genesis.lisp,v 1.71.3.1 92/05/26 22:01:34 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;; $Header: genesis.lisp,v 1.71.3.1 92/05/26 22:01:34 ram Exp $
;;;
;;; Core image builder for CMU Common Lisp.
;;;
;;; Written by Skef Wholey.  Package hackery courtesy of Rob MacLachlan.
;;;
;;; Completely Rewritten by William Lott for MIPS port.
;;;

(in-package "LISP")



;;;; Representation of descriptors and spaces in the core.

(defvar *dynamic* nil)
(defparameter dynamic-space-id 1)

(defvar *static* nil)
(defparameter static-space-id 2)

(defvar *read-only* nil)
(defparameter read-only-space-id 3)

(defmacro round-up (num size)
  "Rounds number up to be an integral multiple of size."
  (let ((size-var (gensym)))
    `(let ((,size-var ,size))
       (* ,size-var (ceiling ,num ,size-var)))))


(defstruct (space
        (:constructor %make-space (name identifier address sap
                        words-allocated))
        (:print-function %print-space))
  name                  ; Name of this space.
  identifier              ; Space Identifier
  address              ; Word address it will be at when loaded.
  sap                  ; System area pointer for this space.
  words-allocated          ; Number of words currently allocated.
  (free-pointer 0))          ; Word offset of next free word.

(defun %print-space (space stream depth)
  (declare (ignore depth))
  (format stream "#<~S space (#x~X), ~S bytes used>"
      (space-name space)
      (ash (space-address space) 2)
      (ash (space-free-pointer space) 2)))

(eval-when (compile eval load)

(defconstant descriptor-low-bits 16
  "Number of bits in the low half of the descriptor")

(defconstant space-alignment (ash 1 descriptor-low-bits)
  "Alignment requirement for spaces in the target.
  Must be at least (ash 1 descriptor-low-bits")

(defvar *target-page-size* (system:get-page-size)
  "The page size to use in the build core.  Set before loading genesis to use a
  value different from the current system page size.")

); eval-when

(defstruct (descriptor
        (:constructor make-descriptor (high low &optional space offset))
        (:print-function %print-descriptor))
  space                  ; The space is descriptor is allocated in.
  offset              ; The offset (in words) from the start of
                  ;  that space.
  high                  ; The high half of the descriptor.
  low                  ; The low half of the descriptor.
  )

(defun %print-descriptor (des stream depth)
  (declare (ignore depth))
  (let ((lowtag (descriptor-lowtag des)))
    (cond ((or (= lowtag vm:even-fixnum-type) (= lowtag vm:odd-fixnum-type))
       (let ((unsigned
          (logior (ash (descriptor-high des)
                   (1+ (- descriptor-low-bits vm:lowtag-bits)))
              (ash (descriptor-low des) (- 1 vm:lowtag-bits)))))
         (if (> unsigned #x1FFFFFFF)
         (format stream "#<fixnum: ~D>"
             (- unsigned #x40000000))
         (format stream "#<fixnum: ~D>" unsigned))))
      ((or (= lowtag vm:other-immediate-0-type)
           (= lowtag vm:other-immediate-1-type))
       (format stream "#<other immediate: #x~X, type #b~8,'0B>"
           (logior (ash (descriptor-high des)
                (- descriptor-low-bits vm:type-bits))
               (ash (descriptor-low des)
                (- vm:type-bits)))
           (logand (descriptor-low des) vm:type-mask)))
      (t
       (format stream "#<pointer: #x~X, lowtag #b~3,'0B, ~A space>"
           (logior (ash (descriptor-high des)
                descriptor-low-bits)
               (logandc2 (descriptor-low des) vm:lowtag-mask))
           lowtag
           (let ((space (descriptor-space des)))
             (if space
             (space-name space)
             "unknown")))))))


(defun make-space (name identifier address
            &optional (initial-size space-alignment))
  (multiple-value-bind
      (ignore remainder)
      (truncate address space-alignment)
    (declare (ignore ignore))
    (unless (zerop remainder)
      (error "The address #x~X is not aligned on a #x~X boundry."
         address space-alignment)))
  (let ((actual-size (round-up initial-size *target-page-size*)))
    (let ((addr (allocate-system-memory actual-size)))
      (%make-space name identifier
           (ash address (- vm:word-shift)) addr
           (ash actual-size (- vm:word-shift))))))

(defun deallocate-space (space)
  (deallocate-system-memory (space-sap space)
                (* (space-words-allocated space) vm:word-bytes)))

(defun allocate-descriptor (space length lowtag)
  "Return a descriptor for a block of LENGTH bytes out of SPACE.  The free
  pointer is boosted as necessary.  If any additional memory is needed, we
  vm_allocate it.  The descriptor returned is a pointer of type LOWTAG."
  (let* ((bytes (round-up length (ash 1 vm:lowtag-bits)))
     (offset (space-free-pointer space))
     (new-free-ptr (+ offset (ash bytes (- vm:word-shift)))))
    (when (> new-free-ptr (space-words-allocated space))
      (do ((size (space-words-allocated space) (* 2 size)))
      ((>= size new-free-ptr)
       (setf (space-sap space)
         (reallocate-system-memory (space-sap space)
                       (ash (space-words-allocated space)
                        vm:word-shift)
                       (ash size vm:word-shift)))
       (setf (space-words-allocated space) size))))
    (setf (space-free-pointer space) new-free-ptr)
    (let ((ptr (+ (space-address space) offset)))
      (make-descriptor (ash ptr (- vm:word-shift descriptor-low-bits))
               (logior (ash (logand ptr
                        (1- (ash 1
                             (- descriptor-low-bits
                            vm:word-shift))))
                    vm:word-shift)
                   lowtag)
               space
               offset))))

(defun descriptor-lowtag (des)
  "Return the lowtag bits for DES."
  (logand (descriptor-low des) vm:lowtag-mask))

(defun descriptor-sap (des)
  "Return a SAP pointing to the piece of memory DES refers to.  The lowtag
  bits of DES are ignored."
  (let ((space (descriptor-space des)))
    (when (null space)
      (let ((lowtag (descriptor-lowtag des))
        (high (descriptor-high des))
        (low (descriptor-low des)))
    (when (or (eql lowtag vm:function-pointer-type)
          (eql lowtag vm:structure-pointer-type)
          (eql lowtag vm:list-pointer-type)
          (eql lowtag vm:other-pointer-type))
      (dolist (space (list *dynamic* *static* *read-only*)
             (error "Could not find a space for ~S" des))
        ;; This code relies on the fact that spaces are aligned such that
        ;; the descriptor-low-bits low bits are zero.
        (when (and (>= high (ash (space-address space)
                     (- vm:word-shift descriptor-low-bits)))
               (<= high (ash (+ (space-address space)
                    (space-free-pointer space))
                     (- vm:word-shift descriptor-low-bits))))
          (setf (descriptor-space des) space)
          (setf (descriptor-offset des)
            (+ (ash (- high (ash (space-address space)
                     (- vm:word-shift descriptor-low-bits)))
                (- descriptor-low-bits vm:word-shift))
               (ash (logandc2 low vm:lowtag-mask) (- vm:word-shift))))
          (return)))))
      (setf space (descriptor-space des)))
    (unless space
      (error "~S has no space?" des))
    (int-sap (+ (sap-int (space-sap space))
        (ash (descriptor-offset des) vm:word-shift)))))


(defun make-random-descriptor (value)
  (make-descriptor (logand (ash value (- descriptor-low-bits))
               (1- (ash 1 (- vm:word-bits descriptor-low-bits))))
           (logand value (1- (ash 1 descriptor-low-bits)))))

(defun make-fixnum-descriptor (num)
  (when (>= (integer-length num)
        (1+ (- vm:word-bits vm:lowtag-bits)))
    (error "~D is too big for a fixnum." num))
  (make-random-descriptor (ash num (1- vm:lowtag-bits))))

(defun make-other-immediate-descriptor (data type)
  (make-descriptor (ash data (- vm:type-bits descriptor-low-bits))
           (logior (logand (ash data (- descriptor-low-bits
                        vm:type-bits))
                   (1- (ash 1 descriptor-low-bits)))
               type)))

(defun make-character-descriptor (data)
  (make-other-immediate-descriptor data vm:base-char-type))

(defun descriptor-beyond (des offset type)
  (let* ((low (logior (+ (logandc2 (descriptor-low des) vm:lowtag-mask)
             offset)
              type))
     (high (+ (descriptor-high des)
          (ash low (- descriptor-low-bits)))))
    (make-descriptor high (logand low (1- (ash 1 descriptor-low-bits))))))


(defun initialize-spaces ()
  (macrolet ((frob (sym name identifier addr)
           `(if ,sym
            (setf (space-free-pointer ,sym) 0)
            (setf ,sym
              (make-space ,name ,identifier ,addr)))))
    (frob *read-only* :read-only read-only-space-id
      vm:target-read-only-space-start)
    (frob *static* :static static-space-id
      vm:target-static-space-start)
    (frob *dynamic* :dynamic dynamic-space-id
      vm:target-dynamic-space-start)))


;;;; Random variables and other noise.

(defparameter unbound-marker
  (make-other-immediate-descriptor 0 vm:unbound-marker-type)
  "Handle on the trap object.")

(defvar *nil-descriptor* nil
  "Handle on Nil.")

(defvar *current-init-functions-cons* nil
  "Head of list of functions to be called when the Lisp starts up.")

(defvar *in-cold-load* nil
  "Used by normal loader.")



;;;; Stuff to read and write the core memory.

(defun maybe-byte-swap (word)
  (declare (type (unsigned-byte 32) word))
  (assert (= vm:word-bits 32))
  (assert (= vm:byte-bits 8))
  (if (eq (c:backend-byte-order c:*native-backend*)
      (c:backend-byte-order c:*backend*))
      word
      (logior (ash (ldb (byte 8 0) word) 24)
          (ash (ldb (byte 8 8) word) 16)
          (ash (ldb (byte 8 16) word) 8)
          (ldb (byte 8 24) word))))

(defun maybe-byte-swap-short (short)
  (declare (type (unsigned-byte 16) short))
  (assert (= vm:word-bits 32))
  (assert (= vm:byte-bits 8))
  (if (eq (c:backend-byte-order c:*native-backend*)
      (c:backend-byte-order c:*backend*))
      short
      (logior (ash (ldb (byte 8 0) short) 8)
          (ldb (byte 8 8) short))))


(defun write-indexed (address index value)
  "Write VALUE (a descriptor) INDEX words from ADDRESS (also a descriptor)."
  (if (and (null (descriptor-space value))
       (not (null (descriptor-offset value))))
      (note-load-time-value-reference
       (int-sap (+ (logandc2 (descriptor-low address) vm:lowtag-mask)
           (ash (descriptor-high address) descriptor-low-bits)
           (ash index vm:word-shift)))
       value)
      (let ((sap (descriptor-sap address))
        (high (descriptor-high value))
        (low (descriptor-low value)))
    (setf (sap-ref-32 sap (ash index vm:word-shift))
          (maybe-byte-swap (logior (ash high 16) low))))))

(defun write-memory (address value)
  "Write VALUE (a descriptor) at ADDRESS (also a descriptor)."
  (write-indexed address 0 value))


(defun read-indexed (address index)
  "Return the value (as a descriptor) INDEX words from ADDRESS (a descriptor)."
  (let* ((sap (descriptor-sap address))
     (value (maybe-byte-swap (sap-ref-32 sap (ash index vm:word-shift)))))
    (make-random-descriptor value)))

(defun read-memory (address)
  "Return the value at ADDRESS (a descriptor)."
  (read-indexed address 0))


;;;; Allocating primitive objects.

;;; There are three kinds of blocks of memory in the new type system:
;;;
;;;   Boxed objects (cons cells, structures, etc):
;;; These objects have no header as all slots are descriptors.
;;;
;;;   Unboxed objects (bignums):
;;; A single header words that contains the length.
;;;
;;;   Vector objects:
;;; A header word with the type, a word for the length, plus the data.
;;;

(defun allocate-boxed-object (space length lowtag)
  "Allocate LENGTH words in SPACE and return a new descriptor of type LOWTAG
  pointing to them."
  (allocate-descriptor space (ash length vm:word-shift) lowtag))

(defun allocate-unboxed-object (space element-size length type)
  "Allocate LENGTH units of ELEMENT-SIZE bits plus a header word in SPACE and
  return an ``other-pointer'' descriptor to them.  Initialize the header word
  with the resultant length and TYPE."
  (let* ((bytes (/ (* element-size length) vm:byte-bits))
     (des (allocate-descriptor space
                   (+ bytes vm:word-bytes)
                   vm:other-pointer-type)))
    (write-memory des
          (make-other-immediate-descriptor (ash bytes (- vm:word-shift))
                           type))
    des))

(defun allocate-vector-object (space element-size length type)
  "Allocate LENGTH units of ELEMENT-SIZE plus a header plus a length slot in
  SPACE and return an ``other-pointer'' descriptor to them.  Initialize the
  header word with TYPE and the length slot with LENGTH."
  (let* ((bytes (/ (* element-size length) vm:byte-bits))
     (des (allocate-descriptor space (+ bytes (* 2 vm:word-bytes))
                   vm:other-pointer-type)))
    (write-memory des (make-other-immediate-descriptor 0 type))
    (write-indexed des vm:vector-length-slot (make-fixnum-descriptor length))
    des))



;;;; Routines to move simple objects into the core.

(defun string-to-core (string &optional (space *dynamic*))
  "Copy string into the CORE and return a descriptor to it."
  ;; Note: We allocate an extra byte and tweek the length back to make sure
  ;; there will be a null at the end of the string to aid in call-out to
  ;; C.
  (let* ((len (length string))
     (des (allocate-vector-object space vm:byte-bits (1+ len)
                      vm:simple-string-type)))
    (write-indexed des vm:vector-length-slot (make-fixnum-descriptor len))
    (copy-to-system-area string (* vm:vector-data-offset vm:word-bits)
             (descriptor-sap des)
             (* vm:vector-data-offset vm:word-bits)
             (* (1+ len) vm:byte-bits))
    des))

(defun bignum-to-core (n)
  "Copy the bignum to the core."
  (let* ((words (ceiling (1+ (integer-length n)) vm:word-bits))
     (handle (allocate-unboxed-object *dynamic* vm:word-bits
                      words vm:bignum-type)))
    (declare (fixnum words))
    (do ((index 1 (1+ index))
     (remainder n (ash remainder (- vm:word-bits))))
    ((> index words)
     (unless (zerop (integer-length remainder))
       (warn "Wrote ~D words of ~D, but ~D was left over"
         words n remainder)))
      (let ((word (ldb (byte vm:word-bits 0) remainder)))
    (write-indexed handle index
               (make-descriptor (ash word (- descriptor-low-bits))
                    (ldb (byte descriptor-low-bits 0)
                         word)))))
    handle))

(defun number-pair-to-core (first second type)
  "Makes a number pair of TYPE (ratio or complex) and fills it in."
  (let ((des (allocate-unboxed-object *dynamic* vm:word-bits 2 type)))
    (write-indexed des 1 first)
    (write-indexed des 2 second)
    des))

(defun float-to-core (num)
  (etypecase num
    (single-float
     (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
                     vm:single-float-size
                     vm:single-float-type)))
       (write-indexed des vm:single-float-value-slot
              (make-random-descriptor (single-float-bits num)))
       des))
    (double-float
     (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
                     vm:double-float-size
                     vm:double-float-type))
       (high-bits (make-random-descriptor (double-float-high-bits num)))
       (low-bits (make-random-descriptor (double-float-low-bits num))))
       (ecase (c:backend-byte-order c:*backend*)
     (:little-endian
      (write-indexed des vm:double-float-value-slot low-bits)
      (write-indexed des (1+ vm:double-float-value-slot) high-bits))
     (:big-endian
      (write-indexed des vm:double-float-value-slot high-bits)
      (write-indexed des (1+ vm:double-float-value-slot) low-bits)))
       des))))

(defun number-to-core (number)
  "Copy the given number to the core, or flame out if we can't deal with it."
  (typecase number
    (integer (if (< (integer-length number) 30)
         (make-fixnum-descriptor number)
         (bignum-to-core number)))
    (ratio (number-pair-to-core (number-to-core (numerator number))
                (number-to-core (denominator number))
                vm:ratio-type))
    (complex (number-pair-to-core (number-to-core (realpart number))
                  (number-to-core (imagpart number))
                  vm:complex-type))
    (float (float-to-core number))
    (t (error "~S isn't a cold-loadable number at all!" number))))

(defun sap-to-core (sap)
  (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
                      vm:sap-size vm:sap-type)))
    (write-indexed des vm:sap-pointer-slot
           (make-random-descriptor (sap-int sap)))
    des))

(defun allocate-cons (space car cdr)
  "Allocate a cons cell in SPACE and fill it in with CAR and CDR."
  (let ((dest (allocate-boxed-object space 2 vm:list-pointer-type)))
    (write-memory dest car)
    (write-indexed dest 1 cdr)
    dest))

(defmacro cold-push (thing list)
  "Generates code to push the THING onto the given cold load LIST."
  `(setq ,list (allocate-cons *dynamic* ,thing ,list)))



;;;; Symbol magic.

;;; Allocate-Symbol allocates a symbol and fills its print name cell and
;;; property list cell.

(defvar *cold-symbol-allocation-space* nil)

(defun allocate-symbol (name)
  (declare (simple-string name))
  (let ((symbol (allocate-unboxed-object
         (or *cold-symbol-allocation-space* *dynamic*)
         vm:word-bits (1- vm:symbol-size) vm:symbol-header-type)))
    (write-indexed symbol vm:symbol-value-slot unbound-marker)
    (write-indexed symbol vm:symbol-function-slot unbound-marker)
    (write-indexed symbol vm:symbol-raw-function-addr-slot
           (make-random-descriptor
            (ecase (c:backend-fasl-file-implementation c:*backend*)
              ((#.c:pmax-fasl-file-implementation
            #.c:rt-fasl-file-implementation
            #.c:rt-afpa-fasl-file-implementation)
               (lookup-foreign-symbol "undefined_tramp"))
              (#.c:sparc-fasl-file-implementation
               (lookup-foreign-symbol "_undefined_tramp")))))
    (write-indexed symbol vm:symbol-setf-function-slot unbound-marker)
    (write-indexed symbol vm:symbol-plist-slot *nil-descriptor*)
    (write-indexed symbol vm:symbol-name-slot (string-to-core name *dynamic*))
    (write-indexed symbol vm:symbol-package-slot *nil-descriptor*)
    symbol))

(defun cold-setq (symbol value)
  (write-indexed symbol vm:symbol-value-slot value))

(defun cold-fset (symbol defn)
  (let ((type (logand (descriptor-low (read-memory defn)) vm:type-mask)))
    (write-indexed symbol vm:symbol-function-slot defn)
    (write-indexed symbol vm:symbol-raw-function-addr-slot
           (ecase (c:backend-fasl-file-implementation c:*backend*)
             ((#.c:pmax-fasl-file-implementation
               #.c:rt-fasl-file-implementation
               #.c:rt-afpa-fasl-file-implementation)
              (ecase type
            (#.vm:function-header-type
             (make-random-descriptor
              (+ (ash (descriptor-high defn) descriptor-low-bits)
                 (logandc2 (descriptor-low defn) vm:lowtag-mask)
                 (ash vm:function-header-code-offset
                  vm:word-shift))))
            (#.vm:closure-header-type
             (make-random-descriptor
              (lookup-foreign-symbol "closure_tramp")))))
             (#.c:sparc-fasl-file-implementation
              (ecase type
            (#.vm:function-header-type defn)
            (#.vm:closure-header-type
             (make-random-descriptor
              (lookup-foreign-symbol "_closure_tramp")))))))))

;;; Cold-Put  --  Internal
;;;
;;;    Add a property to a symbol in the core.  Assumes it doesn't exist.
;;;
(defun cold-put (symbol indicator value)
  (write-indexed symbol
         vm:symbol-plist-slot
         (allocate-cons *dynamic*
            indicator
            (allocate-cons *dynamic*
                   value
                   (read-indexed symbol
                         vm:symbol-plist-slot)))))

;;;; Interning.

;;;    In order to avoid having to know about the package format, we
;;; build a data structure which we stick in *cold-symbols* that
;;; holds all interned symbols along with info about their packages.
;;; The data structure is a list of lists in the following format:
;;;   (<make-package-arglist>
;;;    <internal-symbols>
;;;    <external-symbols>
;;;    <imported-internal-symbols>
;;;    <imported-external-symbols>
;;;    <shadowing-symbols>)
;;;
;;;    Package manipulation forms are dumped magically by the compiler
;;; so that we can eval them at Genesis time.  An eval-for-effect fop
;;; is used, surrounded by fops that switch the fop table to the hot
;;; fop table and back.
;;;

;;; An alist from packages to the list of symbols in that package to be
;;; dumped.

(defvar *cold-packages* nil)

;;; Cold-Intern  --  Internal
;;;
;;;    Return a handle on an interned symbol.  If necessary allocate
;;; the symbol and record which package the symbol was referenced in.
;;; When we allocatethe symbol, make sure we record a reference to
;;; the symbol in the home package so that the package gets set.
;;;
(defun cold-intern (symbol &optional (package (symbol-package symbol)))
  (let ((cold-info (get symbol 'cold-info)))
    (unless cold-info
      (cond ((eq (symbol-package symbol) package)
         (let ((handle (allocate-symbol (symbol-name symbol))))
           (when (eq package *keyword-package*)
         (cold-setq handle handle))
           (setq cold-info
             (setf (get symbol 'cold-info) (cons handle nil)))))
        (t
         (cold-intern symbol)
         (setq cold-info (get symbol 'cold-info)))))
    (unless (memq package (cdr cold-info))
      (push package (cdr cold-info))
      (push symbol (cdr (or (assq package *cold-packages*)
                (car (push (list package) *cold-packages*))))))
    (car cold-info)))

;;; Initialize-Symbols  --  Internal
;;;
;;;    Since the initial symbols must be allocated before we can intern
;;; anything else, we intern those here.  We also set the values of T and Nil.
;;;
(defun initialize-symbols ()
  "Initilizes the cold load symbol-hacking data structures."
  (do-all-symbols (sym)
    (remprop sym 'cold-info))
  (setq *cold-packages* nil)
  (let ((*cold-symbol-allocation-space* *static*))
    ;; Special case NIL.
    (let ((des (allocate-unboxed-object *static* vm:word-bits
                    vm:symbol-size 0)))
      (setf *nil-descriptor*
        (make-descriptor (descriptor-high des)
                 (+ (descriptor-low des) (* 2 vm:word-bytes)
                    (- vm:list-pointer-type
                   vm:other-pointer-type))))
      (write-indexed des 1
             (make-other-immediate-descriptor 0 vm:symbol-header-type))
      (write-indexed des (1+ vm:symbol-value-slot) *nil-descriptor*)
      (write-indexed des (1+ vm:symbol-function-slot) *nil-descriptor*)
      (write-indexed des (1+ vm:symbol-setf-function-slot) unbound-marker)
      (write-indexed des (1+ vm:symbol-plist-slot) *nil-descriptor*)
      (write-indexed des (1+ vm:symbol-name-slot)
             (string-to-core "NIL" *dynamic*))
      (write-indexed des (1+ vm:symbol-package-slot) *nil-descriptor*)
      (setf (get nil 'cold-info) (cons *nil-descriptor* nil))
      (cold-intern nil))

    ;; Intern the others.
    (dolist (symbol vm:static-symbols)
      (let ((des (cold-intern symbol)))
    (unless (= (- (descriptor-low des) (descriptor-low *nil-descriptor*))
           (vm:static-symbol-offset symbol))
      (warn "Offset from ~S to ~S is ~D, not ~D"
        symbol
        nil
        (- (descriptor-low des) (descriptor-low *nil-descriptor*))
        (vm:static-symbol-offset symbol)))))

    ;; Establish the value of T.
    (let ((t-symbol (cold-intern t)))
      (cold-setq t-symbol t-symbol)))

  (setf *current-init-functions-cons* *nil-descriptor*))

;;; Finish-Symbols  --  Internal
;;;
;;;    Establish initial values for magic symbols.
;;;
;;;    Scan over all the symbols referenced in each package in *cold-packages*
;;; making the apropriate entry in the *initial-symbols* data structure to
;;; intern the thing.
;;;
(defun finish-symbols ()
  (macrolet ((frob (symbol value)
           `(cold-setq (cold-intern ',symbol) ,value)))
    (frob *current-catch-block* (make-fixnum-descriptor 0))
    (frob *current-unwind-protect-block* (make-fixnum-descriptor 0))
    (frob *eval-stack-top* (make-fixnum-descriptor 0))

    (frob *free-interrupt-context-index* (make-fixnum-descriptor 0))

    (let ((res *nil-descriptor*))
      (dolist (cpkg *cold-packages*)
    (let* ((pkg (car cpkg))
           (shadows (package-shadowing-symbols pkg)))
      (let ((internal *nil-descriptor*)
        (external *nil-descriptor*)
        (imported-internal *nil-descriptor*)
        (imported-external *nil-descriptor*)
        (shadowing *nil-descriptor*))
        (dolist (sym (cdr cpkg))
          (let ((handle (car (get sym 'cold-info))))
        (multiple-value-bind (found where)
                     (find-symbol (symbol-name sym) pkg)
          (unless (and where (eq found sym))
            (error "Symbol ~S is not available in ~S." sym pkg))
          (when (memq sym shadows)
            (cold-push handle shadowing))
          (case where
            (:internal
             (if (eq (symbol-package sym) pkg)
             (cold-push handle internal)
             (cold-push handle imported-internal)))
            (:external
             (if (eq (symbol-package sym) pkg)
             (cold-push handle external)
             (cold-push handle imported-external)))))))
        (let ((r *nil-descriptor*))
          (cold-push shadowing r)
          (cold-push imported-external r)
          (cold-push imported-internal r)
          (cold-push external r)
          (cold-push internal r)
          (cold-push (make-make-package-args pkg) r)
          (cold-push r res)))))

      (frob *initial-symbols* res)
      (frob *lisp-initialization-functions* *current-init-functions-cons*))

    ;; Nothing should be allocated after this.
    ;;
    (frob *read-only-space-free-pointer*
      (allocate-descriptor *read-only* 0 vm:even-fixnum-type))
    (frob *static-space-free-pointer*
      (allocate-descriptor *static* 0 vm:even-fixnum-type))
    (frob *initial-dynamic-space-free-pointer*
      (allocate-descriptor *dynamic* 0 vm:even-fixnum-type))))

;;; Make-Make-Package-Args  --  Internal
;;;
;;;    Make a cold list that can be used as the arglist to make-package to
;;; make a similar package.
;;;
(defun make-make-package-args (package)
  (let* ((use *nil-descriptor*)
     (nicknames *nil-descriptor*)
     (res *nil-descriptor*))
    (dolist (u (package-use-list package))
      (when (assoc u *cold-packages*)
    (cold-push (string-to-core (package-name u)) use)))
    (dolist (n (package-nicknames package))
      (cold-push (string-to-core n) nicknames))
    (cold-push (number-to-core (truncate (internal-symbol-count package) 0.8)) res)
    (cold-push (cold-intern :internal-symbols) res)
    (cold-push (number-to-core (truncate (external-symbol-count package) 0.8)) res)
    (cold-push (cold-intern :external-symbols) res)

    (cold-push nicknames res)
    (cold-push (cold-intern :nicknames) res)

    (cold-push use res)
    (cold-push (cold-intern :use) res)

    (cold-push (string-to-core (package-name package)) res)
    res))



;;;; Reading FASL files.

(defvar *cold-fop-functions* (replace (make-array 256) fop-functions)
  "FOP functions for cold loading.")

(defvar *normal-fop-functions*)

;;; Define-Cold-FOP  --  Internal
;;;
;;;    Like Define-FOP in load, but looks up the code, and stores into
;;; the *cold-fop-functions* vector.
;;;
(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
  (let ((fname (concat-pnames 'cold- name))
    (code (get name 'fop-code)))
    `(progn
       (defun ,fname ()
     ,@(if (eq pushp :nope)
           forms
           `((with-fop-stack ,pushp ,@forms))))
       ,@(if code
         `((setf (svref *cold-fop-functions* ,code) #',fname))
         (warn "~S is not a defined FOP." name)))))

;;; Clone-Cold-FOP  --  Internal
;;;
;;;    Clone a couple of cold fops.
;;;
(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
  `(progn
    (macrolet ((clone-arg () '(read-arg 4)))
      (define-cold-fop (,name ,pushp) ,@forms))
    (macrolet ((clone-arg () '(read-arg 1)))
      (define-cold-fop (,small-name ,pushp) ,@forms))))

;;; Not-Cold-Fop  --  Internal
;;;
;;;    Define a fop to be undefined in cold load.
;;;
(defmacro not-cold-fop (name)
  `(define-cold-fop (,name)
     (error "~S is not supported in cold load." ',name)))

;;;; Random cold fops...

(define-cold-fop (fop-misc-trap) unbound-marker)

(define-cold-fop (fop-character)
  (make-character-descriptor (read-arg 3)))
(define-cold-fop (fop-short-character)
  (make-character-descriptor (read-arg 1)))

(define-cold-fop (fop-empty-list) *nil-descriptor*)
(define-cold-fop (fop-truth) (cold-intern t))

(define-cold-fop (fop-normal-load :nope)
  (setq fop-functions *normal-fop-functions*))

(define-fop (fop-maybe-cold-load 82 :nope)
  (when *in-cold-load*
    (setq fop-functions *cold-fop-functions*)))

(define-cold-fop (fop-maybe-cold-load :nope))

(clone-cold-fop (fop-struct)
        (fop-small-struct)
  (let* ((size (clone-arg))
     (result (allocate-boxed-object *dynamic* (1+ size)
                    vm:structure-pointer-type)))
    (write-memory result (make-other-immediate-descriptor
              size vm:structure-header-type))
    (do ((index (1- size) (1- index)))
    ((minusp index))
      (declare (fixnum index))
      (write-indexed result (+ index vm:structure-slots-offset) (pop-stack)))
    result))


;;; Loading symbols...

;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns
;;; that symbol in the given Package.
;;;
(defun cold-load-symbol (size package)
  (let ((string (make-string size)))
    (read-n-bytes *fasl-file* string 0 size)
    (cold-intern (intern string package) package)))

(clone-cold-fop (fop-symbol-save)
        (fop-small-symbol-save)
  (push-table (cold-load-symbol (clone-arg) *package*)))

(macrolet ((frob (name pname-len package-len)
         `(define-cold-fop (,name)
        (let ((index (read-arg ,package-len)))
          (push-table
           (cold-load-symbol (read-arg ,pname-len)
                     (svref *current-fop-table* index)))))))
  (frob fop-symbol-in-package-save 4 4)
  (frob fop-small-symbol-in-package-save 1 4)
  (frob fop-symbol-in-byte-package-save 4 1)
  (frob fop-small-symbol-in-byte-package-save 1 1))

(clone-cold-fop (fop-lisp-symbol-save)
        (fop-lisp-small-symbol-save)
  (push-table (cold-load-symbol (clone-arg) *lisp-package*)))

(clone-cold-fop (fop-keyword-symbol-save)
        (fop-keyword-small-symbol-save)
  (push-table (cold-load-symbol (clone-arg) *keyword-package*)))

(clone-cold-fop (fop-uninterned-symbol-save)
        (fop-uninterned-small-symbol-save)
  (let* ((size (clone-arg))
     (name (make-string size)))
    (read-n-bytes *fasl-file* name 0 size)
    (let ((symbol (allocate-symbol name)))
      (push-table symbol))))

;;; Loading lists...

;;; Cold-Stack-List makes a list of the top Length things on the Fop-Stack.
;;; The last cdr of the list is set to Last.

(defmacro cold-stack-list (length last)
  `(do* ((index ,length (1- index))
     (result ,last (allocate-cons *dynamic* (pop-stack) result)))
    ((= index 0) result)
     (declare (fixnum index))))

(define-cold-fop (fop-list)
  (cold-stack-list (read-arg 1) *nil-descriptor*))
(define-cold-fop (fop-list*)
  (cold-stack-list (read-arg 1) (pop-stack)))
(define-cold-fop (fop-list-1)
  (cold-stack-list 1 *nil-descriptor*))
(define-cold-fop (fop-list-2)
  (cold-stack-list 2 *nil-descriptor*))
(define-cold-fop (fop-list-3)
  (cold-stack-list 3 *nil-descriptor*))
(define-cold-fop (fop-list-4)
  (cold-stack-list 4 *nil-descriptor*))
(define-cold-fop (fop-list-5)
  (cold-stack-list 5 *nil-descriptor*))
(define-cold-fop (fop-list-6)
  (cold-stack-list 6 *nil-descriptor*))
(define-cold-fop (fop-list-7)
  (cold-stack-list 7 *nil-descriptor*))
(define-cold-fop (fop-list-8)
  (cold-stack-list 8 *nil-descriptor*))
(define-cold-fop (fop-list*-1)
  (cold-stack-list 1 (pop-stack)))
(define-cold-fop (fop-list*-2)
  (cold-stack-list 2 (pop-stack)))
(define-cold-fop (fop-list*-3)
  (cold-stack-list 3 (pop-stack)))
(define-cold-fop (fop-list*-4)
  (cold-stack-list 4 (pop-stack)))
(define-cold-fop (fop-list*-5)
  (cold-stack-list 5 (pop-stack)))
(define-cold-fop (fop-list*-6)
  (cold-stack-list 6 (pop-stack)))
(define-cold-fop (fop-list*-7)
  (cold-stack-list 7 (pop-stack)))
(define-cold-fop (fop-list*-8)
  (cold-stack-list 8 (pop-stack)))

;;; Loading vectors...

(clone-cold-fop (fop-string)
        (fop-small-string)
  (let* ((len (clone-arg))
     (string (make-string len)))
    (read-n-bytes *fasl-file* string 0 len)
    (string-to-core string)))

(clone-cold-fop (fop-vector)
        (fop-small-vector)
  (let* ((size (clone-arg))
     (result (allocate-vector-object *dynamic* vm:word-bits size
                     vm:simple-vector-type)))
    (do ((index (1- size) (1- index)))
    ((minusp index))
      (declare (fixnum index))
      (write-indexed result (+ index vm:vector-data-offset) (pop-stack)))
    result))

(clone-cold-fop (fop-uniform-vector)
        (fop-small-uniform-vector)
  (let* ((size (clone-arg))
     (datum (pop-stack))
     (result (allocate-vector-object *dynamic* vm:word-bits size
                     vm:simple-vector-type)))
    (do ((index (1- size) (1- index)))
    ((minusp index))
      (declare (fixnum index))
      (write-indexed result (+ index vm:vector-data-offset) datum))
    result))

(define-cold-fop (fop-uniform-int-vector)
  (let* ((len (read-arg 4))
     (size (read-arg 1))
     (type (case size
         (1 vm:simple-bit-vector-type)
         (2 vm:simple-array-unsigned-byte-2-type)
         (4 vm:simple-array-unsigned-byte-4-type)
         (8 vm:simple-array-unsigned-byte-8-type)
         (16 vm:simple-array-unsigned-byte-16-type)
         (32 vm:simple-array-unsigned-byte-32-type)
         (t (error "Losing element size: ~D." size))))
     (value (case size
          ((1 2 4 8)
           (read-arg 1))
          (16
           (read-arg 2))
          (32
           (read-arg 4))))
     (result (allocate-vector-object *dynamic* size len type)))
    (do ((bits size (* bits 2))
     (word value (logior word (ash word bits))))
    ((= size vm:word-bits)
     (let ((datum (make-random-descriptor word)))
       (dotimes (index (ceiling (* len size) vm:word-bits))
         (write-indexed result (+ index vm:vector-data-offset) datum)))))
    result))

(define-cold-fop (fop-int-vector)
  (let* ((len (read-arg 4))
     (size (read-arg 1))
     (type (case size
         (1 vm:simple-bit-vector-type)
         (2 vm:simple-array-unsigned-byte-2-type)
         (4 vm:simple-array-unsigned-byte-4-type)
         (8 vm:simple-array-unsigned-byte-8-type)
         (16 vm:simple-array-unsigned-byte-16-type)
         (32 vm:simple-array-unsigned-byte-32-type)
         (t (error "Losing element size: ~D." size))))
     (result (allocate-vector-object *dynamic* size len type)))
    (unless (zerop len)
      (read-n-bytes *fasl-file*
            (descriptor-sap result)
            (ash vm:vector-data-offset vm:word-shift)
            (ceiling (* len size) vm:byte-bits)))
    result))

(define-cold-fop (fop-single-float-vector)
  (let* ((len (read-arg 4))
     (result (allocate-vector-object *dynamic* vm:word-bits len
                     vm:simple-array-single-float-type)))
    (unless (zerop len)
      (read-n-bytes *fasl-file*
            (descriptor-sap result)
            (ash vm:vector-data-offset vm:word-shift)
            (* len vm:word-bytes)))
    result))

(define-cold-fop (fop-double-float-vector)
  (let* ((len (read-arg 4))
     (result (allocate-vector-object *dynamic* (* vm:word-bits 2) len
                     vm:simple-array-double-float-type)))
    (unless (zerop len)
      (read-n-bytes *fasl-file*
            (descriptor-sap result)
            (ash vm:vector-data-offset vm:word-shift)
            (* len vm:word-bytes 2)))
    result))

(define-cold-fop (fop-array)
  (let* ((rank (read-arg 4))
     (data-vector (pop-stack))
     (result (allocate-boxed-object *dynamic*
                    (+ vm:array-dimensions-offset rank)
                    vm:other-pointer-type)))
    (write-memory result
          (make-other-immediate-descriptor rank vm:simple-array-type))
    (write-indexed result vm:array-fill-pointer-slot *nil-descriptor*)
    (write-indexed result vm:array-data-slot data-vector)
    (write-indexed result vm:array-displacement-slot *nil-descriptor*)
    (write-indexed result vm:array-displaced-p-slot *nil-descriptor*)
    (let ((total-elements 1))
      (dotimes (axis rank)
    (let ((dim (pop-stack)))
      (unless (or (= (descriptor-lowtag dim) vm:even-fixnum-type)
              (= (descriptor-lowtag dim) vm:odd-fixnum-type))
        (error "Non-fixnum dimension? (~S)" dim))
      (setf total-elements
        (* total-elements
           (logior (ash (descriptor-high dim)
                (- descriptor-low-bits (1- vm:lowtag-bits)))
               (ash (descriptor-low dim)
                (- 1 vm:lowtag-bits)))))
      (write-indexed result (+ vm:array-dimensions-offset axis) dim)))
      (write-indexed result vm:array-elements-slot
             (make-fixnum-descriptor total-elements)))
    result))

;;; Loading numbers.

(defmacro cold-number (fop)
  `(define-cold-fop (,fop :nope)
     (,fop)
     (with-fop-stack t
       (number-to-core (pop-stack)))))

(cold-number fop-single-float)
(cold-number fop-double-float)
(cold-number fop-integer)
(cold-number fop-small-integer)
(cold-number fop-word-integer)
(cold-number fop-byte-integer)

(define-cold-fop (fop-ratio)
  (let ((den (pop-stack)))
    (number-pair-to-core (pop-stack) den vm:ratio-type)))

(define-cold-fop (fop-complex)
  (let ((im (pop-stack)))
    (number-pair-to-core (pop-stack) im vm:complex-type)))


;;; Calling (or not calling).

(not-cold-fop fop-eval)
(not-cold-fop fop-eval-for-effect)


(defvar *load-time-value-counter*)

(define-cold-fop (fop-funcall)
  (unless (= (read-arg 1) 0)
    (error "Can't FOP-FUNCALL random stuff in cold load."))
  (let ((counter *load-time-value-counter*))
    (cold-push (allocate-cons
        *dynamic*
        (cold-intern :load-time-value)
        (allocate-cons
         *dynamic*
         (pop-stack)
         (allocate-cons
          *dynamic*
          (number-to-core counter)
          *nil-descriptor*)))
           *current-init-functions-cons*)
    (setf *load-time-value-counter* (1+ counter))
    (make-descriptor 0 0 nil counter)))

(defun note-load-time-value-reference (address marker)
  (cold-push (allocate-cons
          *dynamic*
          (cold-intern :load-time-value-fixup)
          (allocate-cons
           *dynamic*
           (sap-to-core address)
           (allocate-cons
        *dynamic*
        (number-to-core (descriptor-offset marker))
        *nil-descriptor*)))
         *current-init-functions-cons*))

(defun finalize-load-time-value-noise ()
  (cold-setq (cold-intern 'lisp::*load-time-values*)
         (allocate-vector-object *dynamic* vm:word-bits
                     *load-time-value-counter*
                     vm:simple-vector-type)))

(define-cold-fop (fop-funcall-for-effect nil)
  (if (= (read-arg 1) 0)
      (cold-push (pop-stack) *current-init-functions-cons*)
      (error "Can't FOP-FUNCALL random stuff in cold load.")))


;;;; Fixing up circularities.

(define-cold-fop (fop-rplaca nil)
  (let ((obj (svref *current-fop-table* (read-arg 4)))
    (idx (read-arg 4)))
    (write-memory (cold-nthcdr idx obj) (pop-stack))))

(define-cold-fop (fop-rplacd nil)
  (let ((obj (svref *current-fop-table* (read-arg 4)))
    (idx (read-arg 4)))
    (write-indexed (cold-nthcdr idx obj) 1 (pop-stack))))

(define-cold-fop (fop-svset nil)
  (let ((obj (svref *current-fop-table* (read-arg 4)))
    (idx (read-arg 4)))
    (write-indexed obj
           (+ idx
              (ecase (descriptor-lowtag obj)
            (#.vm:structure-pointer-type 1)
            (#.vm:other-pointer-type 2)))
           (pop-stack))))

(define-cold-fop (fop-structset nil)
  (let ((obj (svref *current-fop-table* (read-arg 4)))
    (idx (read-arg 4)))
    (write-indexed obj (1+ idx) (pop-stack))))

(define-cold-fop (fop-nthcdr t)
  (cold-nthcdr (read-arg 4) (pop-stack)))


(defun cold-nthcdr (index obj)
  (dotimes (i index)
    (setq obj (read-indexed obj 1)))
  obj)


;;; Loading code objects and functions.

(define-cold-fop (fop-fset nil)
  (let ((fn (pop-stack))
    (sym (pop-stack)))
    (cold-fset sym fn)))

(defun cold-verify-code-format ()
  (unless *current-code-format*
    (error "Can't load code until after FOP-CODE-FORMAT."))
  (let ((implementation (car *current-code-format*))
    (version (cdr *current-code-format*)))
    (unless (= implementation (c:backend-fasl-file-implementation c:*backend*))
      (error
       "~A was compiled for a ~A, but we are trying to build a core for a ~A"
       *Fasl-file*
       (or (elt c:fasl-file-implementations implementation)
       "unknown machine")
       (or (elt c:fasl-file-implementations
        (c:backend-fasl-file-implementation c:*backend*))
       "unknown machine")))
    (unless (= version (c:backend-fasl-file-version c:*backend*))
      (error
       "~A was compiled for a fasl-file version ~A, but we need version ~A"
       *Fasl-file* version (c:backend-fasl-file-version c:*backend*)))))

(defmacro define-cold-code-fop (name nconst size)
  `(define-cold-fop (,name)
     (cold-verify-code-format)
     (let* ((nconst ,nconst)
        (size ,size)
        (header-size
         ;; Note: we round the number of constants up to assure that
         ;; the code vector will be properly aligned.
         (round-up (+ vm:code-trace-table-offset-slot nconst) 2))
        (des (allocate-descriptor *dynamic*
                      (+ (ash header-size vm:word-shift) size)
                      vm:other-pointer-type)))
       (write-memory des
             (make-other-immediate-descriptor header-size
                              vm:code-header-type))
       (write-indexed des vm:code-code-size-slot
              (make-fixnum-descriptor
               (ash (+ size (1- (ash 1 vm:word-shift)))
                (- vm:word-shift))))
       (write-indexed des vm:code-entry-points-slot *nil-descriptor*)
       (write-indexed des vm:code-debug-info-slot (pop-stack))
       (do ((index (+ nconst (1- vm:code-trace-table-offset-slot))
           (1- index)))
       ((< index vm:code-trace-table-offset-slot))
     (write-indexed des index (pop-stack)))
       (read-n-bytes *fasl-file*
             (descriptor-sap des)
             (ash header-size vm:word-shift)
             size)
       des)))

(define-cold-code-fop fop-code (read-arg 4) (read-arg 4))

(define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2))


(clone-cold-fop (fop-alter-code nil)
        (fop-byte-alter-code)
  (let ((slot (clone-arg))
    (value (pop-stack))
    (code (pop-stack)))
    (write-indexed code slot value)))

(defun calc-offset (code-object after-header)
  (let ((header (read-memory code-object)))
    (+ after-header
       (ash (logior (ash (descriptor-high header)
             (- descriptor-low-bits vm:type-bits))
            (ash (descriptor-low header)
             (- vm:type-bits)))
        vm:word-shift))))

(define-cold-fop (fop-function-entry)
  (let* ((type (pop-stack))
     (arglist (pop-stack))
     (name (pop-stack))
     (code-object (pop-stack))
     (offset (calc-offset code-object (read-arg 4)))
     (fn (descriptor-beyond code-object offset vm:function-pointer-type))
     (next (read-indexed code-object vm:code-entry-points-slot)))
    (unless (zerop (logand offset vm:lowtag-mask))
      (warn "Unaligned function entry: ~S at #x~X" name offset))
    (write-indexed code-object vm:code-entry-points-slot fn)
    (write-memory fn (make-other-immediate-descriptor (ash offset
                               (- vm:word-shift))
                              vm:function-header-type))
    (write-indexed fn vm:function-header-self-slot fn)
    (write-indexed fn vm:function-header-next-slot next)
    (write-indexed fn vm:function-header-name-slot name)
    (write-indexed fn vm:function-header-arglist-slot arglist)
    (write-indexed fn vm:function-header-type-slot type)
    fn))

(define-cold-fop (fop-foreign-fixup)
  (let* ((kind (pop-stack))
     (code-object (pop-stack))
     (len (read-arg 1))
     (sym (make-string len)))
    (read-n-bytes *fasl-file* sym 0 len)
    (let ((offset (calc-offset code-object (read-arg 4))))
      (do-cold-fixup code-object offset (lookup-foreign-symbol sym) kind))
    code-object))

(define-cold-fop (fop-assembler-code)
  (cold-verify-code-format)
  (let* ((length (read-arg 4))
     (header-size
      ;; Note: we round the number of constants up to assure that
      ;; the code vector will be properly aligned.
      (round-up vm:code-constants-offset 2))
     (des (allocate-descriptor *read-only*
                   (+ (ash header-size vm:word-shift) length)
                   vm:other-pointer-type)))
    (write-memory des
          (make-other-immediate-descriptor header-size
                           vm:code-header-type))
    (write-indexed des vm:code-code-size-slot
           (make-fixnum-descriptor
            (ash (+ length (1- (ash 1 vm:word-shift)))
             (- vm:word-shift))))
    (write-indexed des vm:code-entry-points-slot *nil-descriptor*)
    (write-indexed des vm:code-debug-info-slot *nil-descriptor*)

    (read-n-bytes *fasl-file*
          (descriptor-sap des)
          (ash header-size vm:word-shift)
          length)
    des))

(define-cold-fop (fop-assembler-routine)
  (let* ((routine (pop-stack))
     (des (pop-stack))
     (offset (calc-offset des (read-arg 4))))
    (record-cold-assembler-routine
     routine
     (+ (logior (ash (descriptor-high des) descriptor-low-bits)
        (logandc2 (descriptor-low des) vm:lowtag-mask))
    offset))
    des))

(define-cold-fop (fop-assembler-fixup)
  (let* ((routine (pop-stack))
     (kind (pop-stack))
     (code-object (pop-stack))
     (offset (calc-offset code-object (read-arg 4))))
    (record-cold-assembler-fixup routine code-object offset kind)
    code-object))

;;; Cold-Load loads stuff into the core image being built by rebinding
;;; the Fop-Functions table to a table of cold loading functions.

(defun cold-load (filename)
  "Loads the file named by FileName into the cold load image being built."
  (let* ((*normal-fop-functions* fop-functions)
     (fop-functions *cold-fop-functions*)
     (*in-cold-load* t))
    (with-open-file (file (merge-pathnames
               filename
               (make-pathname
                :type (c:backend-fasl-file-type c:*backend*)))
              :element-type '(unsigned-byte 8))
      (load file :verbose nil))))



;;;; Fixups and related stuff.

(defvar *cold-foreign-symbol-table*
  (make-hash-table :test 'equal))

(defun init-foreign-symbol-table ()
  (clrhash *cold-foreign-symbol-table*))

(defun load-foreign-symbol-table (filename)
  (with-open-file (file filename)
    (let* ((version-line (read-line file))
       (last-space (position #\Space version-line :from-end t))
       (version (parse-integer version-line :start (1+ last-space))))
      (loop
    (let ((line (read-line file nil nil)))
      (unless line
        (return))
      (let ((value (parse-integer line :end 8 :radix 16))
        (name (subseq line 11)))
        (multiple-value-bind
        (old-value found)
        (gethash name *cold-foreign-symbol-table*)
          (when found
        (warn "Redefining ~S from #x~X to #x~X" name old-value value)))
        (setf (gethash name *cold-foreign-symbol-table*) value))))
      version)))

(defun lookup-foreign-symbol (name)
  (multiple-value-bind
      (value found)
      (gethash name *cold-foreign-symbol-table* 0)
    (unless found
      (warn "Undefined foreign symbol: ~S" name))
    value))


(defvar *cold-assembler-routines* nil)

(defvar *cold-assembler-fixups* nil)

(defun record-cold-assembler-routine (name address)
  (push (cons name address)
    *cold-assembler-routines*))

(defun record-cold-assembler-fixup
       (routine code-object offset &optional (kind :both))
  (push (list routine code-object offset kind)
    *cold-assembler-fixups*))

(defun lookup-assembler-reference (symbol)
  (let ((value (cdr (assoc symbol *cold-assembler-routines*))))
    (unless value (warn "Assembler routine ~S not defined." symbol))
    value))

(defun resolve-assembler-fixups ()
  (dolist (fixup *cold-assembler-fixups*)
    (let* ((routine (car fixup))
       (value (lookup-assembler-reference routine)))
      (when value
    (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))

(defun do-cold-fixup (code-object offset value kind)
  (let ((sap (sap+ (descriptor-sap code-object) offset)))
    (ecase (c:backend-fasl-file-implementation c:*backend*)
      (#.c:pmax-fasl-file-implementation
       (ecase kind
     (:jump
      (assert (zerop (ash value -26)))
      (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
        (ash value -2)))
     (:lui
      (setf (sap-ref-16 sap 0)
        (+ (ash value -16)
           (if (logbitp 15 value) 1 0))))
     (:addi
      (setf (sap-ref-16 sap 0)
        (ldb (byte 16 0) value)))))
      (#.c:sparc-fasl-file-implementation
       (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
     (ecase kind
       (:call
        (error "Can't deal with call fixups yet."))
       (:sethi
        (setf inst
          (dpb (ldb (byte 22 10) value)
               (byte 22 0)
               inst)))
       (:add
        (setf inst
          (dpb (ldb (byte 10 0) value)
               (byte 10 0)
               inst))))
     (setf (sap-ref-32 sap 0)
           (maybe-byte-swap inst))))
      ((#.c:rt-fasl-file-implementation
    #.c:rt-afpa-fasl-file-implementation)
       (ecase kind
     (:cal
      (setf (sap-ref-16 sap 2)
        (maybe-byte-swap-short
         (ldb (byte 16 0) value))))
     (:cau
      (let ((high (ldb (byte 16 16) value)))
        (setf (sap-ref-16 sap 2)
          (maybe-byte-swap-short
           (if (logbitp 15 value) (1+ high) high)))))
     (:ba
      (unless (zerop (ash value -24))
        (warn "#x~8,'0X out of range for branch-absolute." value))
      (let ((inst (maybe-byte-swap-short (sap-ref-16 sap 0))))
        (setf (sap-ref-16 sap 0)
          (maybe-byte-swap-short
           (dpb (ldb (byte 8 16) value)
            (byte 8 0)
            inst))))
      (setf (sap-ref-16 sap 2)
        (maybe-byte-swap-short (ldb (byte 16 0) value)))))))))


(defun linkage-info-to-core ()
  (let ((result *nil-descriptor*))
    (maphash #'(lambda (symbol value)
         (cold-push (allocate-cons *dynamic*
                       (string-to-core symbol)
                       (number-to-core value))
                result))
         *cold-foreign-symbol-table*)
    (cold-setq (cold-intern '*initial-foreign-symbols*) result))
  (let ((result *nil-descriptor*))
    (dolist (rtn *cold-assembler-routines*)
      (cold-push (allocate-cons *dynamic*
                (cold-intern (car rtn))
                (number-to-core (cdr rtn)))
         result))
    (cold-setq (cold-intern '*initial-assembler-routines*) result)))



;;;; Emit C Header.

(defun tail-comp (string tail)
  (and (>= (length string) (length tail))
       (string= string tail :start1 (- (length string) (length tail)))))

(defun head-comp (string head)
  (and (>= (length string) (length head))
       (string= string head :end1 (length head))))

(defun emit-c-header ()
  (format t "/*~% * Machine generated header file.  Do not edit.~% */~2%")
  (format t "#ifndef _LISP_H_~%#define _LISP_H_~2%")
  (format t "#define lowtag_Bits ~D~%" vm:lowtag-bits)
  (format t "#define lowtag_Mask ((1<<lowtag_Bits)-1)~%")
  (format t "#define LowtagOf(obj) ((obj)&lowtag_Mask)~%")
  (format t "#define type_Bits ~D~%" vm:type-bits)
  (format t "#define type_Mask ((1<<type_Bits)-1)~%")
  (format t "#define TypeOf(obj) ((obj)&type_Mask)~%")
  (format t "#define HeaderValue(obj) ((unsigned long) ((obj)>>type_Bits))~2%")
  (format t "#define Pointerp(obj) ((obj) & 0x01)~%")
  (format t "#define PTR(obj) ((obj)&~~lowtag_Mask)~2%")
  (format t "#define fixnum(n) ((n)<<2)~2%")
  (let ((constants nil))
    (do-external-symbols (symbol (find-package "VM"))
      (when (constantp symbol)
    (let ((name (symbol-name symbol)))
      (labels
          ((record (prefix string priority)
         (push (list (concatenate
                  'simple-string
                  prefix
                  (delete #\- (string-capitalize string)))
                 priority
                 (symbol-value symbol)
                 (documentation symbol 'variable))
               constants))
           (test-tail (tail prefix priority)
         (when (tail-comp name tail)
           (record prefix
               (subseq name 0
                   (- (length name)
                      (length tail)))
               priority)))
           (test-head (head prefix priority)
         (when (head-comp name head)
           (record prefix
               (subseq name (length head))
               priority))))
        (test-tail "-TYPE" "type_" 0)
        (test-tail "-FLAG" "flag_" 1)
        (test-tail "-TRAP" "trap_" 2)
        (test-tail "-SUBTYPE" "subtype_" 3)
        (test-head "TRACE-TABLE-" "tracetab_" 4)))))
    (setf constants
      (sort constants
        #'(lambda (const1 const2)
            (if (= (second const1) (second const2))
            (< (third const1) (third const2))
            (< (second const1) (second const2))))))
    (let ((prev-priority (second (car constants))))
      (dolist (const constants)
    (unless (= prev-priority (second const))
      (terpri)
      (setf prev-priority (second const)))
    (format t "#define ~A ~D~@[  /* ~A */~]~%"
        (first const) (third const) (fourth const))))
    (terpri)
    (format t "#define ERRORS { \\~%")
    (loop
      for info across (c:backend-internal-errors c:*backend*)
      do (format t "    ~S, \\~%" (cdr info)))
    (format t "    NULL \\~%}~%")
    (terpri))
  (let ((structs (sort (copy-list vm:*primitive-objects*) #'string<
               :key #'(lambda (obj)
                (symbol-name (vm:primitive-object-name obj))))))
    (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
    (format t "typedef unsigned long lispobj;~%")
    (format t "#define LISPOBJ(thing) ((lispobj)thing)~2%")
    (dolist (obj structs)
      (format t "struct ~A {~%"
          (nsubstitute #\_ #\-
               (string-downcase
                (string (vm:primitive-object-name obj)))))
      (when (vm:primitive-object-header obj)
    (format t "    lispobj header;~%"))
      (dolist (slot (vm:primitive-object-slots obj))
    (format t "    ~A ~A~@[[1]~];~%"
        (getf (vm:slot-options slot) :c-type "lispobj")
        (nsubstitute #\_ #\-
                 (string-downcase (string (vm:slot-name slot))))
        (vm:slot-rest-p slot)))
      (format t "};~2%"))
    (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
    (format t "#define LISPOBJ(thing) thing~2%")
    (dolist (obj structs)
      (let ((name (vm:primitive-object-name obj))
        (lowtag (eval (vm:primitive-object-lowtag obj))))
    (when lowtag
      (dolist (slot (vm:primitive-object-slots obj))
        (format t "#define ~A_~A_OFFSET ~D~%"
            (substitute #\_ #\- (string name))
            (substitute #\_ #\- (string (vm:slot-name slot)))
            (- (* (vm:slot-offset slot) vm:word-bytes) lowtag)))
      (terpri))))
    (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
  (dolist (symbol (cons nil vm:exported-static-symbols))
    (format t "#define ~A LISPOBJ(0x~X)~%"
        (nsubstitute #\_ #\-
             (remove-if #'(lambda (char)
                    (member char '(#\% #\*)))
                    (symbol-name symbol)))
        (let ((des (cold-intern symbol)))
          (logior (ash (descriptor-high des) descriptor-low-bits)
              (descriptor-low des)))))
  (terpri)
  (format t "#endif _LISP_H_~%"))

;;; FILES-DIFFER --- internal
;;;
;;; Return T iff the two files differ.

(defun files-differ (name1 name2)
  (if (probe-file name1)
      (if (probe-file name2)
      (with-open-file (file1 name1)
        (with-open-file (file2 name2)
          (or (null file2)
          (not (= (file-length file1)
              (file-length file2)))
          (do ((line1 "foo" (read-line file1 nil nil))
               (line2 "foo" (read-line file2 nil nil)))
              ((and (null line1) (null line2)) nil)
            (when (or (null line1)
                  (null line2)
                  (string/= line1 line2))
              (return t))))))
      t)
      (not (null (probe-file name2)))))


;;;; The actual genesis function.

(defvar *genesis-core-name* "lisp.core")
(defvar *genesis-map-name* t)
(defvar *genesis-c-header-name* t)
(defvar *genesis-symbol-table* nil)

(defun genesis (file-list &optional
              (symbol-table *genesis-symbol-table*)
              (core-name *genesis-core-name*)
              (map-name *genesis-map-name*)
              (header-name *genesis-c-header-name*))
  "Builds a kernel Lisp image from the .FASL files specified in the given
  File-List and writes it to a file named by Core-Name."
  (unless symbol-table
    (error "Can't genesis without a symbol-table."))
  (format t "~&Building ~S for the ~A~%"
      core-name (c:backend-version c:*backend*))
  (setq *current-init-functions-cons* *nil-descriptor*)
  (let ((*load-time-value-counter* 0)
    *static* *dynamic* *read-only* *cold-assembler-routines*
    *cold-assembler-fixups*)
    (unwind-protect
    (progn
      (init-foreign-symbol-table)
      (let ((version (load-foreign-symbol-table symbol-table)))
        (initialize-spaces)
        (initialize-symbols)
        (dolist (file (if (listp file-list)
                  file-list
                  (list file-list)))
          (let ((file (truename
               (merge-pathnames file
                        (make-pathname
                         :type
                         (c:backend-fasl-file-type
                          c:*backend*))))))
        (write-line (namestring file))
        (cold-load file))
          (maybe-gc))
        (resolve-assembler-fixups)
        (linkage-info-to-core)
        (finish-symbols)
        (finalize-load-time-value-noise)
        (macrolet
        ((make-name (name type)
           `(if (eq ,name t)
            (make-pathname :type ,type
                       :defaults core-name)
            (merge-pathnames ,name
                     (make-pathname
                      :defaults core-name
                      :type ,type)))))
          (when map-name
        (with-open-file (*standard-output* (make-name map-name "map")
                           :direction :output
                           :if-exists :supersede)
          (write-map-file)))
          (when header-name
        (let* ((name (make-name header-name "h"))
               (new-name (concatenate 'simple-string
                          (namestring name) ".NEW"))
               (won nil))
          (unwind-protect
              (progn
            (with-open-file
                (*standard-output* new-name
                           :direction :output
                           :if-exists :supersede)
              (emit-c-header))
            (unix:unix-chmod (namestring (truename new-name))
                     #o444)
            (setf won t))
            (cond ((and won (files-differ name new-name))
               (rename-file name
                    (concatenate 'simple-string
                             (namestring name)
                             ".OLD"))
               (rename-file new-name name)
               (warn "The C header file has changed.~%Be sure to ~
               re-compile the startup code and re-run Genesis."))
              ((delete-file new-name)))))))
        (write-initial-core-file core-name version)))
      (dolist (space (list *static* *dynamic* *read-only*))
    (when space
      (deallocate-space space))))))



(defun write-map-file ()
  (let ((*print-pretty* nil)
    (*print-case* :upcase))
    (format t "Assembler routines defined in core image:~%~%")
    (dolist (routine *cold-assembler-routines*)
      (format t "~S: #x~X~%" (car routine) (cdr routine)))))


;;;; Core file writing magic.

(defvar *core-file* nil)
(defvar *data-page* 0)

(defparameter version-entry-type-code 3860)
(defparameter validate-entry-type-code 3845)
(defparameter directory-entry-type-code 3841)
(defparameter new-directory-entry-type-code 3861)
(defparameter end-entry-type-code 3840)

(defun write-long (num)
  (ecase (c:backend-byte-order c:*backend*)
    (:little-endian
     (dotimes (i 4)
       (write-byte (ldb (byte 8 (* i 8)) num) *core-file*)))
    (:big-endian
     (dotimes (i 4)
       (write-byte (ldb (byte 8 (* (- 3 i) 8)) num) *core-file*)))))


(defun advance-to-page ()
  (force-output *core-file*)
  (file-position *core-file*
         (round-up (file-position *core-file*)
               *target-page-size*)))

(defun output-space (space)
  (force-output *core-file*)
  (let* ((posn (file-position *core-file*))
     (bytes (* (space-free-pointer space) vm:word-bytes))
     (pages (ceiling bytes *target-page-size*))
     (total-bytes (* pages *target-page-size*)))
    ;;
    (file-position *core-file* (* *target-page-size* (1+ *data-page*)))
    (format t "Writing ~S byte~:P [~S page~:P] from ~S space~%"
        total-bytes pages (space-name space))
    (force-output)
    ;;
    ;; Note: It is assumed that the space allocation routines always
    ;; allocate whole pages (of size *target-page-size*) and that any empty
    ;; space between the free pointer and the end of page will be
    ;; zero-filled.  This will always be true under Mach on machines
    ;; where the page size is equal.  (RT is 4K, PMAX is 4K, Sun 3 is 8K).
    ;;
    (system:output-raw-bytes *core-file* (space-sap space) 0 total-bytes)
    (force-output *core-file*)
    (file-position *core-file* posn)
    ;;
    ;; Write part of a (new) directory entry which looks like this:
    ;;
    ;; SPACE IDENTIFIER
    ;; WORD COUNT
    ;; DATA PAGE
    ;; ADDRESS
    ;; PAGE COUNT
    ;;
    (write-long (space-identifier space))
    (write-long (space-free-pointer space))
    (write-long *data-page*)
    (write-long (/ (ash (space-address space) vm:word-shift)
           *target-page-size*))
    (write-long pages)
    (incf *data-page* pages)))

(defun write-initial-core-file (name version)
  (format t "[Building Initial Core File (version ~D) in file ~S: ~%"
      version (namestring name))
  (force-output)
  (let ((*data-page* 0))
    (with-open-file (*core-file* name
                 :direction :output
                 :element-type '(unsigned-byte 8)
                 :if-exists :rename-and-delete)
      ;; Write the magic number
      ;;
      (write-long (logior (ash (char-code #\C) 24)
              (ash (char-code #\O) 16)
              (ash (char-code #\R) 8)
              (char-code #\E)))

      ;; Write the Version entry.
      ;;
      (write-long version-entry-type-code)
      (write-long 3)
      (write-long version)

      ;; Write the New Directory entry header.
      ;;
      (write-long new-directory-entry-type-code)
      (write-long 17) ; length = 5 words / space * 3 spaces + 2 for header.

      (output-space *read-only*)
      (output-space *static*)
      (output-space *dynamic*)

      ;; Write the End entry.
      ;;
      (write-long end-entry-type-code)
      (write-long 2)))
  (format t "done]~%")
  (force-output))